home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 10 / AACD 10.iso / AACD / Online / SpeakFreely / sfvod < prev    next >
Text File  |  2000-05-17  |  17KB  |  505 lines
  1. #! /usr/bin/perl
  2. $version = "Release 7.1, September MIM";
  3. $AF_INET = 2; $SOCK_DGRAM = 2;
  4. #
  5. #               Speak Freely Voice on Demand Server
  6. #
  7.  
  8.     $host_timeout = 30;
  9.     $live = 0;
  10.     $lchild = -1;
  11.     $lwltell = -1;
  12.     $log = 0;
  13.     $verbose = 0;
  14.     $hexdump = 0;
  15.     $debug = 0;
  16.     $port = 3456;
  17.     $soundfile = "";
  18.     $moptions = "";
  19.     $program = "sfmike -a";
  20.  
  21.     @proto = ( "-vat ", "", "-rtp ", "" );
  22.     @protoName = ( "VAT", "Speak_Freely", "RTP", "Gibberish" );
  23.     @mname = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun",
  24.                "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" );
  25.  
  26.     $me = $0;
  27.     if (rindex($me, "/") >= 0) {
  28.         $me = substr($me, rindex($me, "/") + 1);
  29.     }
  30.  
  31.     #   Process command line arguments
  32.  
  33.     $arghhh = 1;
  34.     while (@ARGV) {
  35.         $arg = shift;
  36.         if (substr($arg, 0, 1) eq "-" & $arghhh) {
  37.  
  38.             #   An argument of a single dash terminates our processing
  39.             #   of arguments.  Any that remain are passed to sfmike.
  40.  
  41.             if (length($arg) == 1) {
  42.                 $arghhh = 0;
  43.                 next;
  44.             }
  45.             $opt = substr($arg, 1, 1);
  46.             $opt =~ tr/A-Z/a-z/;
  47.             $opa = substr($arg, 2);
  48.             if ($opt eq 'a') {        # -A  --  Live audio mode
  49.                 $live = 1;
  50.             } elsif ($opt eq 'd') {   # -D  --  Debug output
  51.                 $debug = 1;
  52.             } elsif ($opt eq 'l') {   # -Lfile  --  Log requests in file
  53.                 $log = 1;
  54.                 open(LOGFILE, ">>" . $opa);
  55.                 select(LOGFILE);
  56.                 $| = 1;
  57.                 select(stdout);
  58.             } elsif ($opt eq 'p') {   # -Pport  --  Listen on given port
  59.                 $port = $opa;
  60.             } elsif ($opt eq 'r') {   # -Rprog  --  Run "prog" to serve requests
  61.                 $program = $opa;
  62.             } elsif ($opt eq 't') {   # -Ttime  --  Time out hosts after time seconds
  63.                 $host_timeout = $opa;
  64.                 if ($host_timeout < 20) {
  65.                     print "Timeout (-t) must be at least 20 seconds.\n";
  66.                     exit;
  67.                 }
  68.             } elsif ($opt eq 'u' || $opt eq '?') {
  69.                 print "sfvod  --  Speak Freely voice on demand server.\n";
  70.                 if (defined $version) {
  71.                     print "           $version.\n"; 
  72.                 }
  73.                 print "Usage: sfvod [options] soundfile...\n";
  74.                 print "Options:\n";
  75.                 print "    -A         Send live audio\n";
  76.                 print "    -Lfile     Log requests in file\n";
  77.                 print "    -Pport     Listen on given port (default 3456)\n";
  78.                 print "    -Rprog     Run prog to process request (default sfmike)\n";
  79.                 print "    -Ttime     Time out inactive hosts after time seconds\n";
  80.                 print "    -U         Print this message\n";
  81.                 print "    -V         Show host connects and disconnects\n";
  82.                 print "    -X         Dump host addresses and packets in hex\n";
  83.                 print "    -          Pass subsequent options to sfmike\n";
  84.                 exit;
  85.             } elsif ($opt eq "v") {   # -V  --  Verbose output
  86.                 $verbose = 1;
  87.             } elsif ($opt eq "x") {   # -X  --  Hexadecimal dump
  88.                 $hexdump = 1;
  89.             }
  90.         } else {
  91.             if (substr($arg, 0, 1) eq "-") {
  92.                 if (length($moptions) > 0) {
  93.                     $moptions .= " ";
  94.                 }
  95.                 $moptions .= $arg;
  96.             } else {
  97.                 if (length($soundfile) > 0) {
  98.                     $soundfile .= " ";
  99.                 }
  100.                 $soundfile .= $arg;
  101.             }
  102.         }
  103.     }
  104.  
  105. #   $AF_INET = 2;                     # These can vary from system to
  106. #   $SOCK_DGRAM = 2;                  # system, so they're suppled by the Makefile
  107.     $EINTR = 4;                       # Interrupted system call status
  108.     $ECHILD = 10;                     # No children status
  109.     $sockaddr = 'S n a4 x8';
  110.     $protocol = getprotobyname('udp'); # We use UDP protocol
  111.     $WNOHANG = defined &WNOHANG ? &WNOHANG : 1;
  112.     $SIG{'CHLD'} = 'reaper';          # Register child process reaper
  113.  
  114.     if ($verbose) {
  115.         print "$me: listening on port $port.\n";
  116.     }
  117.  
  118.     #   Create a socket to listen on the control port and bind
  119.     #   it to the port number.
  120.  
  121.     $sock = pack($sockaddr, $AF_INET, $port + 1, "\0\0\0\0");
  122.     socket(S, $AF_INET, $SOCK_DGRAM, $protocol) || die "Error creating socket: $!";
  123.     bind(S, $sock) || die "Error binding socket: $!";
  124.     select(S);
  125.     $| = 1;
  126.     select(stdout);
  127.  
  128.     $SIG{'ALRM'} = 'tick';            # Register timeout handler
  129.     alarm(10);                        # Set timeout handler
  130.  
  131.     #   If SPEAKFREE_LWL_TELL is defined, fork a process to publish
  132.     #   our identity on the LWL server.
  133.  
  134.     if (defined($ENV{'SPEAKFREE_LWL_TELL'})) {
  135.         if (($lwltell = fork()) == 0) {
  136.             $SIG{'INT'} = 'killed';
  137.             $zexec = "sfspeaker -w$port";
  138.             if ($debug) {
  139.                 print("Exec: $zexec\n");
  140.             }
  141.             exec($zexec);
  142.             exit;
  143.         }
  144.     }
  145.  
  146.     $con = 1;
  147.     while (1) {
  148.  
  149.         #   Wait until a packet arrives from the control port.
  150.  
  151.         #   You might be wondering why we're doing a select()
  152.         #   here when we're only interested in waiting on a
  153.         #   single file discriptor.  Well, the reason is that
  154.         #   there's a stone bug in Perl 5.004 which causes the
  155.         #   first recv() after a signal was processed (hence using
  156.         #   the "restartable system call" mechanism) to return
  157.         #   the null string as the sender's address, notwithstanding
  158.         #   the fact that the data for the packet has been correcly
  159.         #   stored into the string argument.
  160.         #
  161.         #   If one uses select(), however, to block until a
  162.         #   packet is ready to recv(), the problem does not
  163.         #   occur.  So that's the way we'll do it.
  164.  
  165.         $rin = '';
  166.         vec($rin, fileno(S), 1) = 1;
  167.         $nfound = select($rout = $rin, undef, undef, undef);
  168.  
  169.         if ($nfound == 0) {
  170. #           &tick();
  171.             next;
  172.         }
  173.  
  174.         $addr = recv(S, $sockread, 512, 0);
  175.         if (!defined($addr)) {
  176.             if ($debug) {
  177.                 print("Recv error: $!\n");
  178.             }
  179.             if ($! == $EINTR || $! == $ECHILD) {
  180.                 if ($debug) {
  181.                     print(" ...ignoring\n");
  182.                 }
  183.                 next;
  184.             }
  185.             die "Error receiving from socket: $!";
  186.         }
  187.         if ($hexdump) {
  188.             printf("Address, length %d:\n", length($addr));
  189.             &hexdump($addr, '    ');
  190.         }
  191.         if (length($addr) < 16) {
  192.             if ($debug) {
  193.                 print("Recv: Void address\n");
  194.             }
  195.             next;
  196.         }
  197.         if ($hexdump) {
  198.             printf("Packet, length %d:\n", length($sockread));
  199.             &hexdump($sockread, '    ');
  200.         }
  201.         $pr = (ord($sockread) >> 6) & 3;  # Extract protocol from first byte
  202.         ($af, $rport, $inetaddr) = unpack($sockaddr, $addr);
  203.         @inetaddr = unpack('C4', $inetaddr);
  204.         #   Build dotted IP address to pass to sfmike
  205.         $IPaddress = "$inetaddr[0].$inetaddr[1].$inetaddr[2].$inetaddr[3]";
  206.  
  207.         if (defined $hosts{$IPaddress}) {
  208.  
  209.             #   Check for a BYE packet
  210.  
  211.             $isbye = 0;
  212.             if ($pr == 0) {
  213.                 if (ord(substr($sockread, 1, 1)) == 2) {
  214.                     $isbye = 1;
  215.                 }
  216.             } else {
  217.                 $isbye = &isRTCPbye;
  218.             }
  219.             if ($isbye) {
  220.                 if ($debug) {
  221.                     print "BYE received from $IPaddress\n";
  222.                 }
  223.  
  224.                 #   If child process still active, kill it.  This allows
  225.                 #   the user to end the transmission at any time by
  226.                 #   disconnecting.
  227.  
  228.                 if (!$live && ($timer{$hosts{$IPaddress}} == 0)) {
  229.                     if ($debug) {
  230.                         printf "Killing process $hosts{$IPaddress}\n";
  231.                     }
  232.                     kill('INT', $hosts{$IPaddress});
  233.                 }
  234.                 &closeout($IPaddress);
  235.                 &updlive();
  236.                 if ($verbose) {
  237.                     print "$me: $IPaddress bye.\n";
  238.                 }
  239.                 next;
  240.             }
  241.  
  242.             #   If we're in the process of timing out this connection,
  243.             #   reset the timer every time we receive a new packet.
  244.             #   This keeps us from timing out the host and inadvertently
  245.             #   restarting the transmission.
  246.  
  247.             if ($timer{$hosts{$IPaddress}} != 0) {
  248.                 $timer{$hosts{$IPaddress}} = time();
  249.             }
  250.             next;
  251.         }
  252.  
  253.         #   Only look up the host name if we're in verbose mode or
  254.         #   writing a log file.  Host lookups can take a while and
  255.         #   there's no need to create the extra network traffic unless
  256.         #   we really need the host name.
  257.  
  258.         if ($log || $verbose) {
  259.             $name = "";
  260.             ($name, $aliases, $length, @addrs) = gethostbyaddr($inetaddr,
  261.                 length($inetaddr));
  262.             if (length($name) == 0) {
  263.                 $name = $IPaddress;
  264.             }
  265.             if ($verbose) {
  266.                 print "$me: $name ($IPaddress) $protoName[$pr] connect.\n";
  267.             }
  268.  
  269.             #   Write a log file entry in a format strongly resembling
  270.             #   NCSA Common HTTPD log file format.  We always use GMT
  271.             #   and zero for the length of the transmission.  Suitable
  272.             #   ugly hacks could remove these limitations.  In place
  273.             #   of "HTTP" we show the protocol we used for the transmission.
  274.  
  275.             if ($log) {
  276.                 ($ss, $mm, $hh, $mday, $mon, $yy, $wd, $yd, $isdst) =
  277.                     gmtime(time());
  278.                 print LOGFILE 
  279.                     sprintf("%s - - [%02d/%s/%d:%02d:%02d:%02d +0000] \"GET %s %s/1.0\" 200 0\n",
  280.                         $name,
  281.                         $mday, $mname[$mon], $yy + 1900, $hh, $mm, $ss,
  282.                         $soundfile, $protoName[$pr]);
  283.             }
  284.         }
  285.  
  286.         #   Now we're actually ready to do something.  Fork a child
  287.         #   process and invoke sfspeaker (or whatever program the user
  288.         #   specified with the "-r" option) to play whatever was
  289.         #   specified on our command line.  Note that we include
  290.         #   the protocol of the request we received on the command
  291.         #   line in order to respond in the same protocol as that
  292.         #   of the request.
  293.  
  294.         if (!$live && (($child = fork()) == 0)) {
  295.             $SIG{'INT'} = 'killed';
  296.             $zexec = "$program $proto[$pr] $moptions -p$IPaddress/$port $soundfile";
  297.             if ($debug) {
  298.                 print("Exec: $zexec\n");
  299.             }
  300.             exec($zexec);
  301.             exit;
  302.         }
  303.         $con++;
  304.  
  305.         #   Save information about the request in progress:
  306.         #
  307.         #   $children{$child_process_pid} = IP address of host
  308.         #
  309.         #   $timer{$child_process_pid}    = 0 while transmission is
  310.         #                                   underway.  When the child process
  311.         #                                   exits, this is set to the time
  312.         #                                   the process exited, and is updated
  313.         #                                   every time we get another ID
  314.         #                                   packet from the host.  This is
  315.         #                                   used by the timer to timeout
  316.         #                                   hosts that go away without sending
  317.         #                                   a BYE.
  318.         #
  319.         #   $hosts{$IPaddress}            = Child process serving the request
  320.         #                                   from that IP address.
  321.  
  322.         $children{$child} = $IPaddress;
  323.         $timer{$child} = 0;
  324.         $hosts{$IPaddress} = $child;
  325.         &updlive;
  326.     }
  327.  
  328. #   &closeout(ip)  --  Close out host with given IP address
  329.  
  330. sub closeout {
  331.     local($h) = $_[0];
  332.     local($ch) = $hosts{$h};
  333.     delete $children{$ch};
  334.     delete $timer{$ch};
  335.     delete $hosts{$h};
  336. }
  337.  
  338. #   &dumpstat  --  Dump state arrays
  339.  
  340. sub dumpstat {
  341.     print "Children:\n"; foreach $s (keys(%children)) { print "  $s $children{$s}\n"; }
  342.     print "Hosts:\n"; foreach $s (keys(%hosts)) { print "  $s $hosts{$s}\n"; }
  343.     print "Timer:\n"; foreach $s (keys(%timer)) { print "  $s $timer{$s}\n"; }
  344. }
  345.  
  346. #   &killed  --  Catch interrupt when user disconnects before
  347. #                we're done playing the sound.
  348.  
  349. sub killed {
  350.     exit;
  351. }
  352.  
  353. #   &reaper  --  Catch terminating child processes and start
  354. #                the inactivity timeout running.
  355.  
  356. sub reaper {
  357.     local($pid);
  358.  
  359.     if ($debug) {
  360.         print "Reaper...\n";
  361.     }
  362.     while (1) {
  363.         $pid = waitpid(-1, $WNOHANG);
  364.         if ($debug) {
  365.             print "   Reaped process $pid\n";
  366.         }
  367.         last if ($pid < 1);
  368.         if ($live && $pid == $lchild) {
  369.             $lchild = -1;
  370.             &updlive();
  371.         } elsif (defined $timer{$pid}) {
  372.             $timer{$pid} = time();
  373.         }
  374.     }
  375.     if ($debug) {
  376.         print "Reaped.\n";
  377.     }
  378.     $SIG{'CHLD'} = 'reaper';          # Reset child process reaper
  379. }
  380.  
  381. #   &tick  --  Scan the list of open connections and check for any
  382. #              which haven't sent an identity packet in $host_timeout
  383. #              seconds.  If that's the case, terminate the connection
  384. #              (rendering it eligible for re-connection if and when we
  385. #              see another packet from this host).
  386.  
  387. sub tick {
  388.     local($t, $h, $l);
  389.  
  390.     if ($debug) {
  391.         print("Tick...\n");
  392.     }
  393.     $t = time();
  394.     foreach $h (keys(%children)) {
  395.         if ($timer{$h} != 0) {
  396.             $l = time() - $timer{$h};
  397.             if ($l > $host_timeout) {
  398.                 &closeout($children{$h});
  399.                 &updlive();
  400.                 if ($verbose) {
  401.                     print "$me: $IPaddress timeout.\n";
  402.                 }
  403.             }
  404.         }
  405.     }
  406.     alarm(10);
  407.     $SIG{'ALRM'} = 'tick';            # Reset timeout handler
  408. }
  409.  
  410. #   &isRTCPbye  --  See if a received packet is an RTCP BYE
  411.  
  412. sub isRTCPbye {
  413.     local($p0, $p1, $len, $n, $end, $sawbye);
  414.  
  415.     $sawbye = 0;
  416.     $len = length($sockread);
  417.     $p0 = ord($sockread);
  418.     $p1 = ord(substr($sockread, 1, 1));
  419.     if ((($p0 >> 6) == 2 || ($p0 >> 6) == 1) &&
  420.         (($p0 & 0x20) == 0) &&
  421.         (($p1 == 200) || ($p1 == 201))) {
  422.     }
  423.  
  424.     $n = 0;
  425.     do {
  426.         if (ord(substr($sockread, $n + 1, 1)) == 203) {
  427.             $sawbye = 1;
  428.         }
  429.         $n += (((ord(substr($sockread, $n + 2, 1)) * 256) +
  430.                  ord(substr($sockread, $n + 3, 1))) + 1) * 4;
  431.     } while (($n < $len) && ((ord(substr($sockread, $n, 1)) >> 6) == 2));
  432.     $n == $len && $sawbye;
  433. }
  434.  
  435. #   &updlive  --  Update list of active live audio destinations
  436.  
  437. sub updlive {
  438.     local($a, $b, $zexec);
  439.  
  440.     if ($live) {
  441.         if ($lchild >= 0) {
  442.             kill('INT', $lchild);
  443.         } else {
  444.             $a = "";
  445.             foreach $b (keys(%hosts)) {
  446.                 if (length($a) > 0) {
  447.                     $a .= " ";
  448.                 }
  449.                 $a .= "-p$b/$port";
  450.             }
  451.             if (length($a) > 0) {
  452.                 if (verbose) {
  453.                     print "$me: sending to $a.\n";
  454.                 }
  455.                 if (($lchild = fork()) == 0) {
  456.                     $SIG{'INT'} = 'lkilled';
  457.                     $zexec = "$program $moptions $a";
  458.                     if ($debug) {
  459.                         print("Exec: $zexec\n");
  460.                     }
  461.                     exec($zexec);
  462.                     exit;
  463.                 }
  464.             } else {
  465.                 if (verbose) {
  466.                     print "$me: idle.\n";
  467.                 }
  468.             }
  469.         }
  470.     }
  471. }
  472.  
  473. #   &lkilled  --  Catch interrupt when live audio player terminates
  474.  
  475. sub lkilled {
  476.     exit;
  477. }
  478.  
  479. #   &hexdump  --  Dump contents of string in hexadecimal
  480.  
  481. sub hexdump {
  482.     local($d, $xdp) = @_;
  483.     local($adr) = 0;
  484.     local($l) = 0;
  485.  
  486.     while (length($d) > 0) {
  487.         if ($l == 0) {
  488.             printf("%s%04X: ", $xdp, $adr);
  489.         }
  490.         if ($l == 8) {
  491.             printf(" :");
  492.         }
  493.         printf(" %02X", unpack('C', $d));
  494.         $d = substr($d, 1);
  495.         $adr++;
  496.         $l = ($l + 1) % 16;
  497.         if ($l == 0) {
  498.             print("\n");
  499.         }
  500.     }
  501.     if ($l > 0) {
  502.         print("\n");
  503.     }
  504. }
  505.